home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 10 / FM Towns Free Software Collection 10.iso / ms_dos / lib / happyai3 / hpint3.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-12-11  |  36.7 KB  |  893 lines
  1. (*********************************************************************
  2.  *  *** HAPPy P-code Interpreter for HAPPy Version 0.3 ***           *
  3.  *                                                                   *
  4.  *        HAPPyのサンプルプログラム                                  *
  5.  *          (作者  浅野比富美 Public Domain Software)                *
  6.  *********************************************************************)
  7.  
  8. (*
  9.    HPASM3.PASをコンパイルしてできるアセンブラで作成したP-codeオブジェクトを
  10.    解釈実行します。
  11.  
  12.    const,type,var の各部にある * 印がついたものは、アセンブラ、インタプリタ
  13.    共通の定義項目です。
  14. *)
  15.  
  16. program HAPPyPcodeInterpreter(pCode,pConst,input,output) ;
  17.  
  18.   label 9999 ;                          { プログラム出口               }
  19.  
  20.   const
  21.  
  22. {*} SetLow   =    0 ;                   { HAPPy 集合要素順序数 下限値  }
  23. {*} SetHigh  =   31 ;                   { HAPPy 集合要素順序数 上限値  }
  24. {*} MaxCode  = 1000 ;                   { コード部上限                 }
  25. {*} MaxData  = 3000 ;                   { データ部上限                 }
  26.     NilValue =   -1 ;                   { ポインタ nil値               }
  27.  
  28.   (***** データ種別番号 *****)
  29. {*} Inte     =    1 ;                   { 整数データ                   }
  30. {*} Reals    =    2 ;                   { 実数データ                   }
  31. {*} Chars    =    3 ;                   { 文字データ                   }
  32. {*} Bool     =    4 ;                   { 論理データ                   }
  33. {*} Sets     =    5 ;                   { 集合データ                   }
  34. {*} datAd    =    6 ;                   { データ部アドレス             }
  35. {*} codAd    =    7 ;                   { コード部アドレス             }
  36. {*} Multi    =    8 ;                   { 列データ                     }
  37. {*} Nils     =    9 ;                   { nilデータ                    }
  38. {*} Proc     =   10 ;                   { 手続き                       }
  39.  
  40.   type
  41.  
  42.    (*** P-code命令の定義 ***)
  43. {*} opType =      { アルファベット順に並べること         }
  44.          ( iABI,  { absolute integers                    }
  45.            iABR,  { absolute reals                       }
  46.            iADI,  { add integers                         }
  47.            iADR,  { add reals                            }
  48.            iAND,  { and operator                         }
  49.            iATN,  { arctan standard function             }
  50.            iBAS,  { load base mark address               }
  51.            iCHK,  { check value between bounds           }
  52.            iCHR,  { chr standard function                }
  53.            iCKA,  { check address                        }
  54.            iCKS,  { check set (P-codeｿｰｽ上に現れない)    }
  55.            iCOS,  { cos standard function                }
  56.            iCUI,  { call user procedure indirect         }
  57.            iCUP,  { call user procedure                  }
  58.            iDEC,  { decrement                            }
  59.            iDIF,  { difference set                       }
  60.            iDIS,  { dispose standard procedure           }
  61.            iDVI,  { divide integers                      }
  62.            iDVR,  { divide reals                         }
  63.            iEJP,  { extra block jump                     }
  64.            iENT,  { enter procedure or function          }
  65.            iEOF,  { eof standard function                }
  66.            iEOL,  { eoln standard function               }
  67.            iEQU,  { equal operator                       }
  68.            iEXP,  { exp standard function                }
  69.            iFJP,  { jump on false                        }
  70.            iFLO,  { float integer to real on sp-1        }
  71.            iFLT,  { float integer to real                }
  72.            iGEQ,  { grater than equal operator           }
  73.            iGET,  { get from not text                    } { not support }
  74.            iGRT,  { grater than operator                 }
  75.            iINC,  { increment                            }
  76.            iIND,  { indexed fetch                        }
  77.            iINN,  { in operator                          }
  78.            iINT,  { intersection set                     }
  79.            iIOR,  { or operator                          }
  80.            iIXA,  { indeced address                      }
  81.            iLAO,  { load base-level address              }
  82.            iLAP,  { load address of procedure            }
  83.            iLCA,  { load address of constant             }
  84.            iLDA,  { load level p address                 }
  85.            iLDC,  { load constant                        }
  86.            iLDO,  { load contents of base-level address  }
  87.            iLEQ,  { less than equal operator             }
  88.            iLES,  { less than operator                   }
  89.            iLOD,  { load contents of address at level p  }
  90.            iLOG,  { ln standard function                 }
  91.            iMMS,  { make multiple set                    }
  92.            iMOD,  { modulo operator                      }
  93.            iMOV,  { move                                 }
  94.            iMPI,  { mulutiple integers                   }
  95.            iMPR,  { mulutiple reals                      }
  96.            iMSI,  { mark stack indirect                  }
  97.            iMST,  { mark stack                           }
  98.            iNEQ,  { not equal operator                   }
  99.            iNEW,  { new standard procedure               }
  100.            iNGI,  { negative integers                    }
  101.            iNGR,  { negative reals                       }
  102.            iNOT,  { not operator                         }
  103.            iNXT,  { next to                              }
  104.            iNXD,  { next downto                          }
  105.            iODD,  { odd standard function                }
  106.            iORD,  { ord standard function                }
  107.            iPGE,  { page standard procedure              }
  108.            iPUT,  { put from not text                    } { not support }
  109.            iRDC,  { read char                            }
  110.            iRDI,  { read integer                         }
  111.            iRDR,  { read real                            }
  112.            iRET,  { return from procedure or function    }
  113.            iRLN,  { readln standard procedure            }
  114.            iROU,  { round                                }
  115.            iRST,  { reset for not text                   } { not support }
  116.            iRWT,  { rewrite for not text                 } { not support }
  117.            iSBI,  { subtract integers                    }
  118.            iSBR,  { subtract reals                       }
  119.            iSGS,  { create singleton set                 }
  120.            iSIN,  { sin standard function                }
  121.            iSQI,  { square integers                      }
  122.            iSQR,  { square reals                         }
  123.            iSQT,  { sqrt standard function               }
  124.            iSRO,  { store at base-level address          }
  125.            iSTO,  { store indirect                       }
  126.            iSTP,  { stop                                 }
  127.            iSTR,  { store contents at address at level p }
  128.            iTGT,  { get from text                        }
  129.            iTPT,  { put from text                        }
  130.            iTRA,  { trace of execution                   }
  131.            iTRC,  { trunc standard function              }
  132.            iTRS,  { reset for text file                  }
  133.            iTRW,  { rewrite for text file                }
  134.            iUJC,  { check uncondition jump               }
  135.            iUJP,  { uncondition jump                     }
  136.            iUNI,  { union set                            }
  137.            iWLN,  { writeln standard procedure           }
  138.            iWRB,  { write boolean                        }
  139.            iWRC,  { write char                           }
  140.            iWRF,  { write real fix                       }
  141.            iWRI,  { write integer                        }
  142.            iWRR,  { write real                           }
  143.            iWRS,  { write string                         }
  144.            iXJP,  { indexed jump                         }
  145.            iZZZ   { 終わり                               }
  146.          ) ;
  147.  
  148. {*}  codeRange  =  0..MaxCode  ;         { コード部の添字範囲          }
  149. {*}  dataRange  =  0..MaxData  ;         { データ部の添字範囲          }
  150. {*}  dataRange1 = -1..MaxData  ;         { データ部の添字範囲(-1を含む)}
  151. {*}  setType    = set of SetLow..SetHigh;{ 集合 (HAPPy要素順序数制限内)}
  152. {*}  pType      = 0..255       ;         { p オペランドの型            }
  153.  
  154. {*}  codeType   = record                { コード部の中身               }
  155.                     op : opType  ;      {   オペレーション             }
  156.                     p  : pType   ;      {   p オペランド               }
  157.                     q  : integer        {   q オペランド               }
  158.                   end ;
  159.  
  160. {*}  dataKind   = Inte..CodAd                 ;  { dataTypeに用いるもの}
  161. {*}  dataType   = record case dataKind of
  162.                     Inte  : (vi : integer)    ;  { 整数型･列挙型データ }
  163.                     Reals : (vr : real)       ;  { 実数型データ        }
  164.                     Chars : (vc : char)       ;  { 文字型データ        }
  165.                     Bool  : (vb : Boolean)    ;  { 論理型データ        }
  166.                     Sets  : (vs : setType)    ;  { 集合型データ        }
  167.                     DatAd : (va : dataRange1) ;  { データ部アドレス    }
  168.                     CodAd : (vp : codeRange)     { コード部アドレス    }
  169.                   end ;
  170.  
  171.   var
  172.  
  173. {*} pcode     : file of codeType  ;     { P-code コードファイル        }
  174. {*} pConst    : file of dataType  ;     { P-code 定数ファイル          }
  175.  
  176.    (*** P-code仮想計算機記憶装置 ***)
  177. {*} code      : array[codeRange] of codeType  ;  { コード部格納エリア  }
  178. {*} store     : array[dataRange] of dataType  ;  { データ部格納エリア  }
  179.  
  180.    (*** P-code仮想計算機レジスタ ***)
  181.     pc        : codeRange  ;            { プログラムカウンタ           }
  182.     mp        : dataRange  ;            { スタック枠の始まりを保持する }
  183.     np        : dataRange  ;            { ヒープ領域の末尾を保持する   }
  184.     sp        : dataRange1 ;            { スタックポインタ             }
  185.     ep        : dataRange  ;            { スタック枠の最大を保持する   }
  186.  
  187.     inputAdr  : dataRange  ;      { input ファイルバッファ変数アドレス }
  188.     outputAdr : dataRange  ;      { outputファイルバッファ変数アドレス }
  189.  
  190.  
  191. (****************************)
  192. (*      初期設定処理        *)
  193. (****************************)
  194.   procedure initialize ;
  195.     var cc : codeRange ;
  196.         dc : dataRange ;
  197.   begin
  198.    (*** コードファイルの読み込み ***)
  199.     reset(pcode)  ;
  200.     cc := 0 ;
  201.     while not eof(pcode) do
  202.     begin
  203.       read(pcode,code[cc]) ;
  204.       cc := cc + 1
  205.     end ;
  206.  
  207.    (*** 定数ファイルの読み込み ***)
  208.     reset(pconst) ;
  209.     dc := 0 ;
  210.     while not eof(pConst) do
  211.     begin
  212.       read(pConst,store[dc]) ;
  213.       dc := dc + 1
  214.     end ;
  215.  
  216.    (*** レジスタ類初期設定 ***)
  217.     pc := 0       ;
  218.     mp := dc      ;
  219.     sp := mp - 1  ;
  220.     ep := mp      ;
  221.     np := MaxData ;
  222.  
  223.    (*** バッファ変数アドレス設定 ***)
  224.     inputAdr  := mp + 5 ;
  225.     outputAdr := mp + 6
  226.   end {initialize} ;
  227.  
  228. (****************************)
  229. (*   ﾗﾝﾀｲﾑｴﾗｰﾒｯｾｰｼﾞ出力処理 *)
  230. (****************************)
  231.   procedure RunErr(errorNum : integer) ;
  232.   begin
  233.     writeln ;
  234.     write('*** [ADDR=',pc-1:1,'] HAPPy Run-time error R',errorNum:1,
  235.             ': 処理打ち切り ***') ;
  236.     goto 9999
  237.   end ;
  238.  
  239. (****************************)
  240. (*       解釈実行処理       *)
  241. (****************************)
  242.   procedure interpret ;
  243.     var run       : Boolean    ;
  244.         trace     : Boolean    ;
  245.         width     : integer    ;
  246.         ad        : dataRange1 ;
  247.         leng      : integer    ;
  248.         i         : integer    ;
  249.         low,high  : integer    ;
  250.         s         : setType    ;
  251.  
  252.   (**** 基準アドレス取得関数 ****)
  253.     function base(p : pType) : dataRange ;
  254.       var ad : dataRange ;
  255.            i : pType     ;
  256.     begin
  257.       if p = 0 then base := mp
  258.       else  begin
  259.               ad := mp ;
  260.               for i:=1 to p do ad := store[ad+1].va ; { 静鎖をたどる }
  261.               base := ad
  262.             end
  263.     end {base} ;
  264.  
  265.  (***** 文字列比較関数 *****)
  266.     (* 関数値 :  < 0 ･･･ 小さい  0 ･･･ 等しい  >0 ･･･ 大きい *)
  267.    function cmpStr(length : integer) : integer ;
  268.      label 9 ;
  269.      var i    : integer ;
  270.          diff : integer ;
  271.    begin
  272.      for i:=0 to length-1 do
  273.      begin
  274.        diff :=  ord(store[store[sp  ].va+i].vc)
  275.               - ord(store[store[sp+1].va+i].vc) ;
  276.        if diff <> 0 then goto 9
  277.      end ;
  278.    9 :
  279.      cmpStr := diff
  280.    end {cmpStr} ;
  281.  
  282.   begin {interpret}
  283.     run   := true  ;
  284.     trace := false ;
  285.  
  286.     while run do                        { stp 命令を実行するまで       }
  287.       with code[pc] do
  288.       begin
  289.         if trace then                   { トレースが必要な時           }
  290.           writeln(pc:4,':',ord(op):4,
  291.                   ' mp=',mp:4,' ep=',ep:4,' np=',np:4,
  292.                   ' store[',sp:4,']=',store[sp].vi) ;
  293.                                           { ↑ sp=-1 の時は誤り 要検討 }
  294.  
  295.         pc := pc + 1 ;      { 命令をフェッチ後にﾌﾟﾛｸﾞﾗﾑｶｳﾝﾀを更新する  }
  296.  
  297.         case op of
  298.  
  299.           iABI :       (* absolute integers *)
  300.                  store[sp].vi := abs(store[sp].vi) ;
  301.  
  302.           iABR :       (* absolute reals *)
  303.                  store[sp].vr := abs(store[sp].vr) ;
  304.  
  305.           iADI : begin (* add integers *)
  306.                    sp := sp - 1 ;
  307.                    store[sp].vi := store[sp].vi + store[sp+1].vi
  308.                  end ;
  309.  
  310.           iADR : begin (* add reals *)
  311.                    sp := sp - 1 ;
  312.                    store[sp].vr := store[sp].vr + store[sp+1].vr
  313.                  end ;
  314.  
  315.           iAND : begin (* and operator *)
  316.                    sp := sp - 1 ;
  317.                    store[sp].vb := store[sp].vb and store[sp+1].vb
  318.                  end ;
  319.  
  320.           iATN :       (* arctan standard function *)
  321.                  store[sp].vr := arctan(store[sp].vr) ;
  322.  
  323.           iBAS : begin (* load base mark address *)
  324.                    sp := sp + 1 ;
  325.                    store[sp].va := base(p)
  326.                  end ;
  327.  
  328.           iCHK :       (* check value between bounds *)
  329.                  if (store[sp].vi < store[q  ].vi) or
  330.                     (store[sp].vi > store[q+1].vi) then RunErr(p) ;
  331.  
  332.           iCHR : begin (* chr standard function *)
  333.                    if (0 > store[sp].vi) or (255 < store[sp].vi) then
  334.                      RunErr(37) ;  {  引数値異常 }
  335.                    store[sp].vc := chr(store[sp].vi)
  336.                  end ;
  337.  
  338.           iCKA :       (* check address *)
  339.                  if      store[sp].va = NilValue then RunErr(3)   { nil  }
  340.                  else if store[sp].va < np       then RunErr(4) ; { 不定 }
  341.  
  342.           iCKS :       (* check set *)
  343.                  if not (store[sp].vs <= store[q].vs) then RunErr(p) ;
  344.  
  345.           iCOS :       (* cos standard function *)
  346.                  store[sp].vr := cos(store[sp].vr) ;
  347.  
  348.           iCUI : begin (* call user procedure indirect *)
  349.                    sp := sp - 1         ;
  350.                    mp := sp - (p + 4)   ;
  351.                    store[mp+4].vp := pc ;
  352.                    pc := store[sp+1].vp
  353.                  end ;
  354.  
  355.           iCUP : begin (* call user procedure *)
  356.                    mp := sp - (p+4) ;
  357.                    store[mp+4].vp := pc ;
  358.                    pc := q
  359.                  end ;
  360.  
  361.           iDEC :       (* decrement *)
  362.                  case p of
  363.                    DatAd : store[sp].va := store[sp].va - q ;
  364.                    Inte  : store[sp].vi := store[sp].vi - q ;
  365.                    Bool  : store[sp].vb := false ;  { 偽以外になることはない }
  366.                    Chars : store[sp].vc := chr(ord(store[sp].vc) - q)
  367.                  end ;
  368.  
  369.           iDIF : begin (* difference set *)
  370.                    sp := sp - 1 ;
  371.                    store[sp].vs := store[sp].vs - store[sp+1].vs
  372.                  end ;
  373.  
  374.           iDIS : begin (* dispose standard procedure *)
  375.                    ad := store[sp].va ;
  376.                    if ad = NilValue then RunErr(23) ;  { 引数の値がnil }
  377.                    if np <= ad then
  378.                    begin
  379.                      if ad = np then np := np + q { 最も最近にnewされた時のみ }
  380.                    end
  381.                    else RunErr(24)                    { 引数の値が不定 }
  382.                  end ;
  383.  
  384.           iDVI : begin (* divide integers *)
  385.                    if store[sp].vi = 0 then RunErr(45) ;  { div演算子 0除算 }
  386.                    sp := sp - 1 ;
  387.                    store[sp].vi := store[sp].vi div store[sp+1].vi
  388.                  end ;
  389.  
  390.           iDVR : begin (* divide reals *)
  391.                    if store[sp].vr = 0.0 then RunErr(44); { /  演算子 0除算 }
  392.                    sp := sp - 1 ;
  393.                    store[sp].vr := store[sp].vr / store[sp+1].vr
  394.                  end ;
  395.  
  396.           iEJP : begin (* extra block jump *)
  397.                    ad := base(p) ;
  398.                    while mp <> ad do              { スタックの枠を解放 }
  399.                    begin
  400.                      sp := mp - 1 ;
  401.                      ep := store[mp+3].va ;
  402.                      mp := store[mp+2].va         { 動鎖 }
  403.                    end ;
  404.                    pc := q
  405.                  end ;
  406.  
  407.           iENT : begin (* enter procedure or function *)
  408.                    if mp + p + q -1 > maxData then RunErr(122) ;
  409.                    sp := mp + q - 1 ;
  410.                    ep := sp + p     ;
  411.                    if ep >= np then RunErr(122)   { スタック用メモリ不足 }
  412.                  end ;
  413.  
  414.           iEOF : begin (* eof standard function *)
  415.                    sp := sp + 1 ;
  416.                    if p = 0 then store[sp].vb := eof(input)
  417.                             else store[sp].vb := eof(output)  { 常に真 }
  418.                  end ;
  419.  
  420.           iEOL : begin (* eoln standard function *)
  421.                    sp := sp + 1 ;
  422.                    if p = 0 then store[sp].vb := eoln(input)
  423.                             else RunErr(42)  { outputは常にeofが真だから誤り }
  424.                                              { 本物はバグのため誤りにならない}
  425.                  end ;
  426.  
  427.           iEQU : begin (* equal operator *)
  428.                    sp := sp - 1 ;
  429.                    case p of
  430.                      DatAd : store[sp].vb := store[sp].va = store[sp+1].va ;
  431.                      Inte  : store[sp].vb := store[sp].vi = store[sp+1].vi ;
  432.                      Reals : store[sp].vb := store[sp].vr = store[sp+1].vr ;
  433.                      Bool  : store[sp].vb := store[sp].vb = store[sp+1].vb ;
  434.                      Sets  : store[sp].vb := store[sp].vs = store[sp+1].vs ;
  435.                      Multi : store[sp].vb := cmpStr(q)    = 0              ;
  436.                      Chars : store[sp].vb := store[sp].vc = store[sp+1].vc
  437.                    end
  438.                  end ;
  439.  
  440.           iEXP :       (* exp standard function *)
  441.                  store[sp].vr := exp(store[sp].vr) ;
  442.  
  443.           iFJP : begin (* jump on false *)
  444.                    if not store[sp].vb then pc := q ;
  445.                    sp := sp - 1
  446.                  end ;
  447.  
  448.           iFLO :       (* float integer to real on sp-1 *)
  449.                  store[sp-1].vr := store[sp-1].vi ;
  450.  
  451.           iFLT :       (* float integer to real *)
  452.                  store[sp].vr := store[sp].vi     ;
  453.  
  454.           iGEQ : begin (* grater than equal operator *)
  455.                    sp := sp - 1 ;
  456.                    case p of
  457.                      Inte  : store[sp].vb := store[sp].vi >= store[sp+1].vi ;
  458.                      Reals : store[sp].vb := store[sp].vr >= store[sp+1].vr ;
  459.                      Bool  : store[sp].vb := store[sp].vb >= store[sp+1].vb ;
  460.                      Sets  : store[sp].vb := store[sp].vs >= store[sp+1].vs ;
  461.                      Multi : store[sp].vb := cmpStr(q)    >= 0              ;
  462.                      Chars : store[sp].vb := store[sp].vc >= store[sp+1].vc
  463.                    end
  464.                  end ;
  465.  
  466.           iGET : ;     (* get from not text *)
  467.                  { input,output以外のファイルはサポートしないので
  468.                    この命令は出現しない }
  469.  
  470.           iGRT : begin (* grater than operator *)
  471.                    sp := sp - 1 ;
  472.                    case p of
  473.                      Inte  : store[sp].vb := store[sp].vi > store[sp+1].vi ;
  474.                      Reals : store[sp].vb := store[sp].vr > store[sp+1].vr ;
  475.                      Bool  : store[sp].vb := store[sp].vb > store[sp+1].vb ;
  476.                      Multi : store[sp].vb := cmpStr(q)    > 0              ;
  477.                      Chars : store[sp].vb := store[sp].vc > store[sp+1].vc
  478.                    end
  479.                  end ;
  480.  
  481.           iINC :       (* increment *)
  482.                  case p of
  483.                    DatAd : store[sp].va := store[sp].va + q ;
  484.                    Inte  : store[sp].vi := store[sp].vi + q ;
  485.                    Bool  : store[sp].vb := true ;     { 真以外はありえない }
  486.                    Chars : store[sp].vc := chr(ord(store[sp].vc) + q)
  487.                  end ;
  488.  
  489.           iIND :       (* indexed fetch *)
  490.                  store[sp] := store[store[sp].va+q] ;
  491.  
  492.           iINN : begin (* in operator *)
  493.                    sp := sp - 1 ;
  494.                    store[sp].vb := store[sp].vi in store[sp+1].vs
  495.                  end ;
  496.  
  497.           iINT : begin (* intersection set *)
  498.                    sp := sp - 1 ;
  499.                    store[sp].vs := store[sp].vs * store[sp+1].vs
  500.                  end ;
  501.  
  502.           iIOR : begin (* or operator *)
  503.                    sp := sp - 1 ;
  504.                    store[sp].vb := store[sp].vb or store[sp+1].vb
  505.                  end ;
  506.  
  507.           iIXA : begin (* indeced address *)
  508.                    sp := sp - 1 ;
  509.                    store[sp].va := store[sp].va +
  510.                       store[q+1].vi * (store[sp+1].vi - store[q].vi)
  511.                  end ;
  512.  
  513.           iLAO ,       (* load base-level address  *)
  514.           iLCA : begin (* load address of constant *)
  515.                    sp := sp + 1 ;
  516.                    store[sp].va := q
  517.                  end ;
  518.  
  519.           iLAP : begin (* load address of procedure *)
  520.                    sp := sp + 1 ;
  521.                    store[sp].vp := q
  522.                  end ;
  523.  
  524.           iLDA : begin (* load level p address *)
  525.                    sp := sp + 1 ;
  526.                    store[sp].va := base(p) + q
  527.                  end ;
  528.  
  529.           iLDC : begin (* load constant *)
  530.                    sp := sp + 1 ;
  531.                    case p of
  532.                      Nils  : store[sp].va := NilValue    ;  { nil値ロード }
  533.                      Inte  : store[sp].vi := q           ;
  534.                      Reals : store[sp].vr := store[q].vr ;
  535.                      Bool  : store[sp].vb := q = 1       ;
  536.                      Sets  : store[sp].vs := store[q].vs ;
  537.                      Chars : store[sp].vc := chr(q)
  538.                    end
  539.                  end ;
  540.  
  541.           iLDO : begin (* load contents of base-level address *)
  542.                    sp := sp + 1 ;
  543.                    if (p = Chars) and (q = inputAdr) then { input^に対する }
  544.                    begin                                  {   ldoc命令     }
  545.                      store[inputAdr].vc := input^ ;
  546.                      store[sp      ].vc := input^
  547.                    end
  548.                    else store[sp] := store[q]
  549.                   { それ以外のldo命令はデータタイプ関係なく丸ごとロード }
  550.                  end ;
  551.  
  552.           iLEQ : begin (* less than equal operator *)
  553.                    sp := sp - 1 ;
  554.                    case p of
  555.                      Inte  : store[sp].vb := store[sp].vi <= store[sp+1].vi ;
  556.                      Reals : store[sp].vb := store[sp].vr <= store[sp+1].vr ;
  557.                      Bool  : store[sp].vb := store[sp].vb <= store[sp+1].vb ;
  558.                      Sets  : store[sp].vb := store[sp].vs <= store[sp+1].vs ;
  559.                      Multi : store[sp].vb := cmpStr(q)    <= 0              ;
  560.                      Chars : store[sp].vb := store[sp].vc <= store[sp+1].vc
  561.                    end
  562.                  end ;
  563.  
  564.           iLES : begin (* less than operator *)
  565.                    sp := sp - 1 ;
  566.                    case p of
  567.                      Inte  : store[sp].vb := store[sp].vi < store[sp+1].vi ;
  568.                      Reals : store[sp].vb := store[sp].vr < store[sp+1].vr ;
  569.                      Bool  : store[sp].vb := store[sp].vb < store[sp+1].vb ;
  570.                      Multi : store[sp].vb := cmpStr(q)    < 0              ;
  571.                      Chars : store[sp].vb := store[sp].vc < store[sp+1].vc
  572.                    end
  573.                  end ;
  574.  
  575.           iLOD : begin (* load contents of address at level p *)
  576.                    sp := sp + 1 ;
  577.                    store[sp] := store[base(p)+q]
  578.                  end ;
  579.  
  580.           iLOG : begin (* ln standard function *)
  581.                    if store[sp].vr <= 0.0 then RunErr(33) ; { 引数が0以下 }
  582.                    store[sp].vr := ln(store[sp].vr)
  583.                  end ;
  584.  
  585.           iMMS : begin (* make multiple set *)
  586.                    sp := sp - 1 ;
  587.                    if p <= 1 then               { p in [0,1] }
  588.                    begin
  589.                      low  := store[sp  ].vi   ;
  590.                      high := store[sp+1].vi
  591.                    end
  592.                    else                         { p in [2,3] }
  593.                    begin
  594.                      low  := store[sp+1].vi ;
  595.                      high := store[sp  ].vi
  596.                    end ;
  597.                    if p in [1,3] then           { -d ﾃﾞﾊﾞｯｸﾞｵﾌﾟｼｮﾝｺﾝﾊﾟｲﾙ }
  598.                      if ( low <= high) and      { 要素が作られる条件     }
  599.                         ((low < SetLow) or (high > SetHigh)) then
  600.                        RunErr(112) ;            { 集合要素順序数範囲外   }
  601.                    s := [] ;
  602.                    for i:=low to high do s := s + [i] ;
  603.                    store[sp].vs := s
  604.                  end ;
  605.  
  606.           iMOD : begin (* modulo operator *)
  607.                    if store[sp].vi <= 0 then RunErr(46) ; { 被演算子 <=0 }
  608.                    sp := sp - 1 ;
  609.                    store[sp].vi := store[sp].vi mod store[sp+1].vi
  610.                  end ;
  611.  
  612.           iMOV : begin (* move *)
  613.                    if p = 1 then
  614.                      for i:=0 to q-1 do
  615.                        store[store[sp-1].va+i] := store[store[sp  ].va+i]
  616.                    else { p = 2 }
  617.                      for i:=0 to q -1 do
  618.                        store[store[sp  ].va+i] := store[store[sp-1].va+i] ;
  619.                    sp := sp - 2
  620.                  end ;
  621.  
  622.           iMPI : begin (* mulutiple integers *)
  623.                    sp := sp - 1 ;
  624.                    store[sp].vi := store[sp].vi * store[sp+1].vi
  625.                  end ;
  626.  
  627.           iMPR : begin (* mulutiple reals *)
  628.                    sp := sp - 1 ;
  629.                    store[sp].vr := store[sp].vr * store[sp+1].vr
  630.                  end ;
  631.  
  632.           iMSI : begin (* mark stack indirect *)
  633.                    sp := sp - 1 ;
  634.                    store[sp+2].va := store[sp+1].va ;
  635.                    store[sp+3].va := mp ;
  636.                    store[sp+4].va := ep ;
  637.                    sp := sp + 5
  638.                  end ;
  639.  
  640.           iMST : begin (* mark stack *)
  641.                    store[sp+2].va := base(p) ;    { 静鎖 }
  642.                    store[sp+3].va := mp ;         { 動鎖 }
  643.                    store[sp+4].va := ep ;
  644.                    sp := sp + 5
  645.                  end ;
  646.  
  647.           iNEQ : begin (* not equal operator *)
  648.                    sp := sp - 1 ;
  649.                    case p of
  650.                      Datad : store[sp].vb := store[sp].va <> store[sp+1].va ;
  651.                      Inte  : store[sp].vb := store[sp].vi <> store[sp+1].vi ;
  652.                      Reals : store[sp].vb := store[sp].vr <> store[sp+1].vr ;
  653.                      Bool  : store[sp].vb := store[sp].vb <> store[sp+1].vb ;
  654.                      Sets  : store[sp].vb := store[sp].vs <> store[sp+1].vs ;
  655.                      Multi : store[sp].vb := cmpStr(q)    <> 0              ;
  656.                      Chars : store[sp].vb := store[sp].vc <> store[sp+1].vc
  657.                    end
  658.                  end ;
  659.  
  660.           iNEW : begin (* new standard procedure *)
  661.                    np := np - q ;                 { q : 割当要求量 }
  662.                    if np <= ep then RunErr(121) ; { メモリ不足で割り付け不能 }
  663.                    store[store[sp].va].va := np ;
  664.                    sp := sp - 1
  665.                  end ;
  666.  
  667.           iNGI :       (* negative integers *)
  668.                  store[sp].vi := -store[sp].vi ;
  669.  
  670.           iNGR :       (* negative reals *)
  671.                  store[sp].vr := -store[sp].vr ;
  672.  
  673.           iNOT :       (* not operator *)
  674.                  store[sp].vb := not store[sp].vb ;
  675.  
  676.           iNXT :       (* next to *)
  677.                  case p of
  678.                    Inte  : store[mp+q].vi := succ(store[mp+q].vi) ;
  679.                    Bool  : store[mp+q].vb := succ(store[mp+q].vb) ;
  680.                    Chars : store[mp+q].vc := succ(store[mp+q].vc)
  681.                  end ;
  682.  
  683.           iNXD :       (* next downto *)
  684.                  case p of
  685.                    Inte  : store[mp+q].vi := pred(store[mp+q].vi) ;
  686.                    Bool  : store[mp+q].vb := pred(store[mp+q].vb) ;
  687.                    Chars : store[mp+q].vc := pred(store[mp+q].vc)
  688.                  end ;
  689.  
  690.           iODD :       (* odd standard function *)
  691.                  store[sp].vb := odd(store[sp].vi) ;
  692.  
  693.           iORD :       (* ord standard function *)
  694.                  case p of
  695.                    Chars : store[sp].vi := ord(store[sp].vc) ; { ordc }
  696.                    Bool  : store[sp].vi := ord(store[sp].vb)   { ordb }
  697.                  end ;
  698.  
  699.           iPGE :       (* page standard procedure *)
  700.                 if p = 0 then RunErr(9)    { inputは生成モードでない  }
  701.                          else page(output) ;
  702.  
  703.           iPUT : ;     (* put from not text *)
  704.                  { input,output以外のファイルはサポートしないので
  705.                    この命令は出現しない }
  706.  
  707.           iRDC : begin (* read character *)
  708.                    if p = 1 then RunErr(14) ; { outputは検査モードでない }
  709.                    read(input,store[store[sp].va].vc) ;
  710.                    store[inputAdr].vc := input^ ;
  711.                    sp := sp - 1
  712.                  end ;
  713.  
  714.           iRDI : begin (* read integer *)
  715.                    if p = 1 then RunErr(14) ; { outputは検査モードでない }
  716.                    read(input,store[store[sp].va].vi) ;
  717.                    store[inputAdr].vc := input^ ;
  718.                    sp := sp - 1
  719.                  end ;
  720.  
  721.           iRDR : begin (* read real *)
  722.                    if p = 1 then RunErr(14) ; { outputは検査モードでない }
  723.                    read(input,store[store[sp].va].vr) ;
  724.                    store[inputAdr].vc := input^ ;
  725.                    sp := sp - 1
  726.                  end ;
  727.  
  728.           iRET : begin (* return from procedure or function *)
  729.                    if p = Proc then sp := mp - 1    { 手続きの戻り }
  730.                                else sp := mp ;      { 関数  の戻り }
  731.                    pc := store[mp+4].vp ;
  732.                    ep := store[mp+3].va ;
  733.                    mp := store[mp+2].va
  734.                  end ;
  735.  
  736.           iRLN :       (* readln standard procedure *)
  737.                    if p = 1 then RunErr(14)   { outputは検査モードでない }
  738.                             else readln(input) ;
  739.  
  740.           iROU :       (* round standard function *)
  741.                  store[sp].vi := round(store[sp].vr) ;
  742.  
  743.           iRST : ;     (* reset for not text *)
  744.                  { input,output以外のファイルはサポートしないので
  745.                    この命令は出現しない }
  746.  
  747.           iRWT : ;     (* rewrite for not text *)
  748.                  { input,output以外のファイルはサポートしないので
  749.                    この命令は出現しない }
  750.  
  751.           iSBI : begin (* subtract integers *)
  752.                    sp := sp - 1 ;
  753.                    store[sp].vi := store[sp].vi - store[sp+1].vi
  754.                  end ;
  755.  
  756.           iSBR : begin (* subtract reals *)
  757.                    sp := sp - 1 ;
  758.                    store[sp].vr := store[sp].vr - store[sp+1].vr
  759.                  end ;
  760.  
  761.           iSGS :       (* create singleton set *)
  762.                  store[sp].vs := [store[sp].vi] ;
  763.  
  764.           iSIN :       (* sin standard function *)
  765.                  store[sp].vr := sin(store[sp].vr) ;
  766.  
  767.           iSQI :       (* square integers *)
  768.                  store[sp].vi := sqr(store[sp].vi) ;
  769.  
  770.           iSQR :       (* square reals *)
  771.                    store[sp].vr := sqr(store[sp].vr) ;
  772.  
  773.           iSQT : begin (* sqrt standard function *)
  774.                    if store[sp].vr < 0.0 then RunErr(34) ; { 引数が負 }
  775.                    store[sp].vr := sqrt(store[sp].vr)
  776.                  end ;
  777.  
  778.           iSRO : begin (* store at base-level address *)
  779.                    store[q] := store[sp] ;
  780.                    sp := sp - 1
  781.                  end ;
  782.  
  783.           iSTO : begin (* store indirect *)
  784.                    store[store[sp-1].va] := store[sp] ;
  785.                    sp := sp - 2
  786.                  end ;
  787.  
  788.           iSTP :       (* stop *)
  789.                  run := false ;
  790.  
  791.           iSTR : begin (* store contents at address at level p *)
  792.                    store[base(p)+q] := store[sp] ;
  793.                    sp := sp - 1
  794.                  end ;
  795.  
  796.           iTGT : begin (* get from text *)
  797.                    if p = 1 then RunErr(14) ; { outputは検査モードでない }
  798.                    get(input) ;
  799.                    store[inputAdr].vc := input^
  800.                  end ;
  801.  
  802.           iTPT : begin (* put from text *)
  803.                    if p = 0 then RunErr(9)  ; { inputは生成モードでない  }
  804.                    output^ := store[outputAdr].vc ;
  805.                    put(output)
  806.                  end ;
  807.  
  808.           iTRA :       (* trace of execution *)
  809.                  trace := p = 1 ;
  810.  
  811.           iTRC :       (* trunc standard function *)
  812.                  store[sp].vi := trunc(store[sp].vr) ;
  813.  
  814.           iTRS :       (* reset for text file *)
  815.                  RunErr(81) ; { input,outputファイルに対してresetできない }
  816.  
  817.           iTRW :       (* rewrite for text file *)
  818.                  RunErr(82) ; { input,outputファイルに対してrewriteできない }
  819.  
  820.           iUJC :       (* check uncondition jump *)
  821.                  RunErr(51) ; { case文の選択式の値に合致する選択定数がない }
  822.  
  823.           iUJP :       (* uncondition jump *)
  824.                  pc := q ;
  825.  
  826.           iUNI : begin (* union set *)
  827.                    sp := sp - 1 ;
  828.                    store[sp].vs := store[sp].vs + store[sp+1].vs
  829.                  end ;
  830.  
  831.           iWLN :       (* writeln standard procedure *)
  832.                  if p = 0 then RunErr(9)      { inputは生成モードでない  }
  833.                           else writeln(output)  ;
  834.  
  835.           iWRB : begin (* write boolean *)
  836.                    if p = 0 then RunErr(9)  ; { inputは生成モードでない  }                         write(output,store[sp-1].vb:store[sp].vi) ;
  837.                    sp := sp - 2
  838.                  end ;
  839.  
  840.           iWRC : begin (* write char *)
  841.                    if p = 0 then RunErr(9)  ; { inputは生成モードでない  }
  842.                    write(output,store[sp-1].vc:store[sp].vi) ;
  843.                    sp := sp -2
  844.                  end ;
  845.  
  846.           iWRF : begin (* write real fix *)
  847.                    if p = 0 then RunErr(9)  ; { inputは生成モードでない  }
  848.                    write(output,store[sp-2].vr:store[sp-1].vi:store[sp].vi) ;
  849.                    sp := sp - 3
  850.                  end ;
  851.  
  852.           iWRI : begin (* write integer *)
  853.                    if p = 0 then RunErr(9)  ; { inputは生成モードでない  }
  854.                    write(output,store[sp-1].vi:store[sp].vi) ;
  855.                    sp := sp - 2
  856.                  end ;
  857.  
  858.           iWRR : begin (* write real *)
  859.                    if p = 0 then RunErr(9)  ; { inputは生成モードでない  }
  860.                    write(output,store[sp-1].vr:store[sp].vi) ;
  861.                    sp := sp - 2
  862.                  end ;
  863.  
  864.           iWRS : begin (* write string *)
  865.                    if p = 2 then RunErr(9)  ; { inputは生成モードでない  }
  866.                            { p = 2 は 正確にはoutput以外のファイルの意味 }
  867.                    width := store[sp].vi   ;
  868.                    ad    := store[sp-1].va ;
  869.                    leng  := q ;
  870.                    if width > leng then write(output,' ':width-leng)
  871.                                    else leng := width ;
  872.                    for i:=0 to leng-1 do write(output,store[ad+i].vc) ;
  873.                    sp := sp - 2
  874.                  end ;
  875.  
  876.           iXJP : begin (* indexed jump *)
  877.                    pc := pc + store[sp].vi ;
  878.                    sp := sp - 1
  879.                  end
  880.  
  881.         end {case op}
  882.       end {with code[pc]}
  883.   end {interpret} ;
  884.  
  885. (****************************)
  886. (*       メイン処理         *)
  887. (****************************)
  888. begin
  889.   initialize ;                          { 初期設定 }
  890.   interpret  ;                          { 解釈実行 }
  891. 9999:
  892. end.
  893.